unit DAttributes;

interface

uses
  SysUtils
  , Rtti
  , TypInfo
  , Variants
  ;

const
  UNSUPPORTED_VALUE_KINDS = [tkClass, tkClassRef, tkPointer] + tkMethods;

type
  DefaultValue=class(TCustomAttribute)
  private
    FDefValue: Variant;
  public
    constructor Create; overload;
    constructor Create(const AIntValue: Integer); overload;
    constructor Create(const AByteValue: Byte); overload;
    constructor Create(const AStrValue: string); overload;
    constructor Create(const AExtValue: Extended); overload;

    procedure Reset(AObj: TObject; const AProp: TRttiProperty); overload;
    procedure Reset(AObj: TObject; APropName: string); overload;

    property DefValue: Variant read FDefValue;
  end;

  DefaultValueClass = class of DefaultValue;

  procedure Reset(AObj: TObject); overload;
  procedure Reset(AObj: TObject; APropName: string); overload;
  function CompareFloats(const Val1, Val2: Double): Integer;
  function IsEqualFloats(const Val1, Val2: Double): Boolean;

implementation

function CompareFloats(const Val1, Val2: Double): Integer;
begin
  Result:= Ord(Val1 > Val2) or (-Ord(Val1 < Val2));
end;

function IsEqualFloats(const Val1, Val2: Double): Boolean;
begin
  Result := CompareFloats(Val1, Val2) = 0;
end;

procedure Reset(AObj: TObject; APropName: string);
var
  vCtx: TRttiContext;
  vType: TRttiType;
  vProp: TRttiProperty;
  vAttr: TCustomAttribute;
begin
  APropName := UpperCase(APropName);
  vCtx := TRttiContext.Create;
  try
    vType := vCtx.GetType(AObj.ClassType);
    for vProp in vType.GetProperties do
      if UpperCase(vProp.Name)=APropName then
      begin
        for vAttr in vProp.GetAttributes do
          if vAttr is DefaultValue then
            DefaultValue(vAttr).Reset(AObj, vProp);
        Break;
      end;
  finally
    vCtx.Free;
  end;
end;

procedure Reset(AObj: TObject);
var
  vCtx: TRttiContext;
  vType: TRttiType;
  vProp: TRttiProperty;
  vAttr: TCustomAttribute;
begin
  vCtx := TRttiContext.Create;
  try
    vType := vCtx.GetType(AObj.ClassType);
    for vProp in vType.GetProperties do
      for vAttr in vProp.GetAttributes do
        if vAttr is DefaultValue then
        begin
          DefaultValue(vAttr).Reset(AObj, vProp);
          Break;
        end;
  finally
    vCtx.Free;
  end;
end;

{ DefaultValue }

procedure DefaultValue.Reset(AObj: TObject; const AProp: TRttiProperty);
var
  I: Int64;
  F: Extended;
  vValue: Rtti.TValue;
begin
  // meaningless to continue when there is no specific default value, or
  // the property is read-only
  if VarIsEmpty(FDefValue) or (not AProp.IsWritable) then
    Exit;

  vValue := AProp.GetValue(AObj);
  if not (vValue.Kind in UNSUPPORTED_VALUE_KINDS) then
  begin
    case vValue.Kind of
      tkChar
      , tkString
      , tkWChar
      , tkLString
      , tkWString
      , tkUString : vValue := VarToStr(Self.DefValue);

      tkInteger
      , tkInt64   :
        begin
          I := VarAsType(Self.DefValue, varInt64);
          vValue := I;
        end;

      tkFloat     :
        begin
          F := VarAsType(Self.DefValue, varDouble);
          vValue := F;
        end
      else
        raise Exception.Create('Data type not supported yet');
    end;
    AProp.SetValue(AObj, vValue);
  end;
end;

constructor DefaultValue.Create(const AIntValue: Integer);
begin
  FDefValue := AIntValue;
end;

constructor DefaultValue.Create(const AByteValue: Byte);
begin
  FDefValue := AByteValue;
end;

constructor DefaultValue.Create(const AStrValue: string);
begin
  FDefValue := AStrValue;
end;

procedure DefaultValue.Reset(AObj: TObject; APropName: string);
var
  vCtx: TRttiContext;
  vType: TRttiType;
  vProp: TRttiProperty;
begin
  APropName := UpperCase(APropName);
  vCtx := TRttiContext.Create;
  try
    vType := vCtx.GetType(AObj.ClassType);
    for vProp in vType.GetProperties do
      if UpperCase(vProp.Name)=APropName then
      begin
        Reset(AObj, vProp);
        Break;
      end;
  finally
    vCtx.Free;
  end;
end;

constructor DefaultValue.Create(const AExtValue: Extended);
begin
  FDefValue := AExtValue;
end;

constructor DefaultValue.Create;
begin
  FDefValue := varEmpty;
end;

end.
